home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d18
/
ffind.arc
/
FFIND.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-28
|
13KB
|
609 lines
{ Copyright (c) 1989 by Chris Thompson (CompuServe 76367,106) }
program FFind;
{ Usage: FFind [d:] [filemask] /switches }
{ note: FFIND /H will provide a help screen}
{$M 32768,0,0}
{A+ Align Data}
{B- Boolean Expressions}
{$I- I/O Checking}
{$R- Range Checking}
{$S- Stack Checking}
{$D- Debug Info}
{$L- Local symbols}
{$N- Emulator}
{$V- Var String Checking}
{ Note - this program is coded for maximum readability, }
{ reliability, and maintainability, not }
{ for fastest possible execution speed. }
{ Screen I/O speed is also limited by maintaining }
{ support for DOS redirection of output. }
{ 1.1 first general release }
{ 1.2 simplified IntToCommaStr algorithm 2/23/89 }
{ simplified String conversion routines }
uses Crt,Dos;
const
MonthStr: array[1..12] of string[3] = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
DayStr: array[0..6] of string[3] =
('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
type
TargetStr = String[12];
DriveStr = String;
Str3 = String[3];
Str2 = String[2];
var
PgmName: String[8];
Prn: Text;
Con: Text;
FoundCount: Integer;
TotalBytes: Longint;
Col : Integer;
LineCount: Byte;
DriveLetter: String;
TargetFile: TargetStr;
SaveDir: DirStr;
DummyDir: DirStr;
DummyName: NameStr;
DummyExt: ExtStr;
PauseMode,
PrintingDirs,
WideDir : Boolean;
savedExitProc: Pointer;
procedure FindFiles(Dir:PathStr;Target:TargetStr); forward;
function UpperCase (InpStr:String) : String;
{Convert a string to Uppercase}
var
i: integer;
begin
for i:= 1 to length(InpStr) do
InpStr[i]:=UpCase(InpStr[i]);
UpperCase:=InpStr;
end;
function LoCase(InChar:char): char;
{ convert a Character to lower case }
begin
if InChar in ['A'..'Z'] then
LoCase := Chr(ord(InChar)+32)
else
LoCase := InChar;
end;
function LowerCase(InpStr:string):string;
{ convert a String to lower case Characters }
var
i : integer;
begin
for i := 1 to Length(InpStr) do
LowerCase[i] := LoCase(InpStr[i]);
LowerCase[0] := InpStr[0]
end;
function NumStr(N:longint;D:Integer): String;
{Integer to String with Leading Zeros D places wide}
begin
NumStr[0] := Chr(D);
while D > 0 do
begin
NumStr[D] := Chr(N mod 10 + Ord('0'));
N := N div 10;
Dec(D);
end;
end;
function IntToCommaStr(N:longint): String;
{Comma string from any + or - integer}
const
s: byte = 0;
var
W: string[11];
i: byte;
d: byte;
begin
Str(N,W);
if W[1] = '-' then s := 1;
d := Length(W);
for i := 3 to (d-1-s) do
if i mod 3 = 0 then
Insert(',',W,(d-I+1+s));
IntToCommaStr := W;
end;
procedure XHour(HourMil:Integer; var HourCiv :Integer; var ampm : Str2);
begin
if HourMil > 11 then
ampm := 'pm'
else
ampm := 'am';
Case HourMil of
0: HourCiv := 12;
1..12: HourCiv := HourMil;
else HourCiv := HourMil-12;
end;
end;
procedure FlushKbd;
var
Ch: Char;
begin
If KeyPressed then
repeat
Ch := ReadKey;
If Ch = #0 then Ch := ReadKey;
If Ch = #3 then Halt(0);
If Ch = #27 then Halt(0);
until (not KeyPressed);
end;
procedure BackSpace(var f:text;n:longint);
begin
while n > 0 do
begin
Write(Con,#8,' ',#8);
Dec(n);
end;
end;
procedure WaitForKeyPress;
begin
repeat
;
until KeyPressed;
end;
function DayNumber(FilDate:DateTime): word;
var
SysDate:DateTime;
DayofWeek: word;
begin
with SysDate do GetDate(Year, Month,Day,DayofWeek);{save system date }
with FilDate do SetDate(Year,Month,Day); {set sys date from file}
with FilDate do GetDate(Year,Month,Day,DayofWeek);{get DoW from sys }
with SysDate do SetDate(Year,Month,Day); {restore sys date }
DayNumber := DayofWeek;
end;
procedure Pause;
const
Msg = 'Program paused; press any key to continue...';
begin
FlushKbd;
Write(Con,Msg);
WaitForKeyPress;
FlushKbd;
BackSpace(Con,Length(Msg));
LineCount := 1;
end;
procedure NewLine(var f:Text);
begin
WriteLn(f);
Col := 0;
If PauseMode then
begin
LineCount := LineCount+1;
If LineCount > 24 then
Pause;
end;
end;
procedure Beep;
begin
Sound(880);
Delay(50);
NoSound;
end;
procedure WriteHelp;
begin
WriteLn(Prn);
WriteLn(Prn,'Usage: ',PgmName,' [d:] [filespec] [switches] ');
WriteLn(Prn);
WriteLn(Prn,'[d:] is the drive to search; if this is not');
WriteLn(Prn,' specified, the default drive is used');
WriteLn(Prn);
WriteLn(Prn,'[filespec] is optional; if omitted, *.* is used');
WriteLn(Prn);
WriteLn(Prn,'Switches:');
WriteLn(Prn);
WriteLn(Prn,' /W Wide format');
WriteLn(Prn,' /O Omit directories');
WriteLn(Prn,' /P Pause Mode');
WriteLn(Prn,' /H Help');
WriteLn(Prn);
WriteLn(Prn,'Output may be redirected to a file or device, e.g:');
WriteLn(Prn);
WriteLn(Prn,' >LPT1:');
WriteLn(Prn,'or');
WriteLn(Prn,' >fname.ext');
end;
{$F+} procedure ProgramExit; {$F-}
begin
If (errorAddr <> nil) then
begin
WriteLn('Program Failed; ExitCode= ',exitcode);
end
else if (exitCode <> 0) then
begin
WriteLn(Con);
case ExitCode of
1: WriteLn(Con,'Invalid FileSpec');
2: WriteLn(Con,'Invalid Parameter');
end;
end;
Close(Prn);
Close(Con);
exitProc := savedExitProc;
end;
procedure PrintTotals;
begin
If Col > 0 then
NewLine(Prn);
NewLine(Prn);
If FoundCount <= 0 then
begin
Write(Prn,'no files found');
NewLine(Prn);
end;
NewLine(Prn);
Write(Prn,'Files found: ',IntToCommaStr(FoundCount));
NewLine(Prn);
Write(Prn,'Total bytes: ',IntToCommaStr(TotalBytes));
NewLine(Prn);
Write(Prn,'Drive ',DriveLetter,': ',
'bytes free: ',
IntToCommaStr(DiskFree(Ord(DriveLetter[1])-64)));
NewLine(Prn);
Beep;
end;
procedure InitPgm;
begin
SetCBreak(True);
CheckBreak := False;
savedExitProc := exitProc;
exitProc := @ProgramExit;
Assign(Prn,'');
Rewrite(Prn);
AssignCrt(Con);
Rewrite(Con);
LineCount := 1;
FoundCount := 0;
TotalBytes := 0;
Col := 0;
SaveDir := '';
end;
procedure GetCommand;
var
I: Integer;
S: PathStr;
D: DirStr;
N: NameStr;
E: ExtStr;
begin
PauseMode := False;
WideDir := False;
PrintingDirs := True;
DriveLetter := '';
TargetFile := '';
if Lo(DosVersion) >= 3 then
begin
FSplit(ParamStr(0), D,N,E);
PgmName := UpperCase(N);
end
else PgmName := 'FFIND';
NewLine(Con);
Write(Con,PgmName,'-',
'File Find Ver 1.2 (C) Copyright 1989 C.C. Thompson');
NewLine(Con);
for I := 1 to ParamCount do
begin
S := ParamStr(I);
if S[1] = '/' then
begin
if Length(S) > 1 then
case UpCase(S[2]) of
'W': WideDir := True;
'O': PrintingDirs := False;
'P': PauseMode := True;
'H': begin
WriteHelp;
Halt(0);
end;
else Halt(2);
end {Case}
else;
end {S[1] = /}
else {must either be drive or filespec}
if ((Length(S) = 2) and (S[2] = ':')) then
DriveLetter := UpCase(S[1])
else TargetFile := Copy(S,1,13);
end;
FlushKbd;
If DriveLetter = '' then
DriveLetter := Copy(FExpand(''),1,1);
FSplit(TargetFile,DummyDir,N,E);
if N = '' then
if ((E = '.') or (E = '..')) then
Halt(1)
else N := '*';
if E = '' then E := '.*';
TargetFile := N + E;
if DummyDir <> '' then
begin
NewLine(Con);
Write(Con,'The path ',DummyDir, ' is ignored');
NewLine(Con);
end;
NewLine(Con);
Write(Prn,' ':8,'Filespec ', DriveLetter + ':\'+TargetFile,
' used for search');
NewLine(Prn);
end;
procedure PrintEntry(Dir:DirStr; FileData:SearchRec);
var
N: NameStr;
E: ExtStr;
T: DateTime;
ampm: Str2;
THour: Integer;
FSize: String;
begin
if Col > 4 then
begin
NewLine(Prn);
Col := 0;
end;
if Dir <> SaveDir then
begin
SaveDir := Dir;
if Col > 0 then
NewLine(Prn);
NewLine(Prn);
Write(Prn,Dir);
NewLine(Prn);
end;
with FileData do
begin
if ((Attr and Directory) or (Attr and VolumeID) = 0) then
Name := LowerCase(Name);
FSplit(Name,DummyDir,N,E);
if (Attr and VolumeID) <> 0 then
begin
if Col > 0 then
NewLine(Prn);
NewLine(Prn);
Write(Prn,' ':8,'Volume ',N,' ':6,'created');
SaveDir := '';
end
else
begin
if WideDir then
begin
Write(Prn,' ':2,N+E, ' ':(13 - Length(N+E)));
Col := Col + 1;
Exit;
end
else
begin
Write(Prn,' ':8,N,E,
' ':(13 - (Length(N)+Length(E))));
if (Attr and Directory) = 0 then
begin
FSize := IntToCommaStr((Size));
Write(Prn,'':9-Length(FSize),FSize,' bytes ')
end
else
Write(Prn,' ':6,'<DIR>',' ':6);
end;
end;
UnpackTime(Time, T);
XHour(T.Hour,THour, ampm);
Write(Prn,
THour: 4, ':',
NumStr(T.Min, 2), ' ',
ampm, ' ',
DayStr[DayNumber(T)],' ',
MonthStr[T.Month], ' ',
T.Day:2,' ',
NumStr(T.Year mod 100, 2));
NewLine(Prn);
end; {with FileData}
end;
procedure DosErrorExit;
begin
NewLine(Con);
case DosError of
3: Write(Con,'Invalid drive specification ');
151..163: case DosError of
152: Write(Con,'Unable to read From drive ',DriveLetter);
162: Write(Con,'General Failure on drive ',DriveLetter);
else Write(Con,'Critical Error ',DosError);
end;
else Write(Con,'Error ',DosError,' Program terminated abnormally');
end;
NewLine(Con);
Halt;
end;
procedure FindVolID(Drive:DriveStr);
var
Path: PathStr;
FoundVol: SearchRec;
begin
if KeyPressed then Pause;
Path := Drive + ':\'+ '*.';
FindFirst(Path,VolumeID,FoundVol);
while (DosError = 0) do
begin
if FoundVol.Attr and VolumeID <> 0 then
begin
PrintEntry('',FoundVol);
Exit;
end;
if KeyPressed then Pause;
FindNext(FoundVol);
end;
if DosError = 18 then
begin
NewLine(Prn);
Write(Prn,' ':8,'Volume in drive ',DriveLetter,' has no label');
NewLine(Prn);
end
else DosErrorExit;
end;
procedure SearchCurrent(Dir:PathStr;Target:TargetStr);
var
Path: PathStr;
FoundFile: SearchRec;
begin
If KeyPressed then Pause;
Path := Dir + Target;
FindFirst(Path,
Hidden + ReadOnly + Directory + Archive + SysFile, FoundFile);
while (DosError = 0) do
begin
if (FoundFile.attr and directory = 0) or PrintingDirs then
begin
Inc(FoundCount);
Inc(TotalBytes, FoundFile.Size);
PrintEntry(Dir,FoundFile);
end;
If KeyPressed then Pause;
FindNext(FoundFile);
end; {read loop}
if DosError <> 18 then DosErrorExit;
end;
procedure SearchSubDirs(Dir:PathStr;Target:TargetStr);
var
FoundDir: SearchRec;
FileSpec: PathStr;
Path : DirStr;
begin
If KeyPressed then Pause;
FileSpec:= Dir + '*.';
FindFirst(FileSpec, Hidden + ReadOnly + Directory + Archive + SysFile, FoundDir);
while (DosError = 0) do
begin
with FoundDir do
begin
If Name[1] <> '.' then
if Directory and Attr <> 0 then
begin
FSplit(FileSpec,Path,DummyName,DummyExt);
FindFiles(Path + Name + '\' ,Target);
end;
end; {with FoundDir}
if KeyPressed then Pause;
FindNext(FoundDir);
end; {read loop}
If DOSError <> 18 then DosErrorExit;
end;
procedure FindFiles(Dir:PathStr;Target:TargetStr);
begin
SearchCurrent(Dir,Target);
SearchSubDirs(Dir,Target);
end;
begin
InitPgm;
GetCommand;
FindVolID(DriveLetter);
FindFiles(DriveLetter+':\',TargetFile);
PrintTotals;
end.